home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / lib / perl / 5.10.0 / re.pm < prev    next >
Text File  |  2009-10-01  |  5KB  |  173 lines
  1. package re;
  2.  
  3. # pragma for controlling the regex engine
  4. use strict;
  5. use warnings;
  6.  
  7. our $VERSION     = "0.08";
  8. our @ISA         = qw(Exporter);
  9. our @EXPORT_OK   = qw(is_regexp regexp_pattern regmust 
  10.                       regname regnames regnames_count);
  11. our %EXPORT_OK = map { $_ => 1 } @EXPORT_OK;
  12.  
  13. # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  14. #
  15. # If you modify these values see comment below!
  16.  
  17. my %bitmask = (
  18.     taint   => 0x00100000, # HINT_RE_TAINT
  19.     eval    => 0x00200000, # HINT_RE_EVAL
  20. );
  21.  
  22. # - File::Basename contains a literal for 'taint' as a fallback.  If
  23. # taint is changed here, File::Basename must be updated as well.
  24. #
  25. # - ExtUtils::ParseXS uses a hardcoded 
  26. # BEGIN { $^H |= 0x00200000 } 
  27. # in it to allow re.xs to be built. So if 'eval' is changed here then
  28. # ExtUtils::ParseXS must be changed as well.
  29. #
  30. # *** WARNING *** WARNING *** WARNING *** WARNING *** WARNING ***
  31.  
  32. sub setcolor {
  33.  eval {                # Ignore errors
  34.   require Term::Cap;
  35.  
  36.   my $terminal = Tgetent Term::Cap ({OSPEED => 9600}); # Avoid warning.
  37.   my $props = $ENV{PERL_RE_TC} || 'md,me,so,se,us,ue';
  38.   my @props = split /,/, $props;
  39.   my $colors = join "\t", map {$terminal->Tputs($_,1)} @props;
  40.  
  41.   $colors =~ s/\0//g;
  42.   $ENV{PERL_RE_COLORS} = $colors;
  43.  };
  44.  if ($@) {
  45.     $ENV{PERL_RE_COLORS} ||= qq'\t\t> <\t> <\t\t';
  46.  }
  47.  
  48. }
  49.  
  50. my %flags = (
  51.     COMPILE         => 0x0000FF,
  52.     PARSE           => 0x000001,
  53.     OPTIMISE        => 0x000002,
  54.     TRIEC           => 0x000004,
  55.     DUMP            => 0x000008,
  56.     FLAGS           => 0x000010,
  57.  
  58.     EXECUTE         => 0x00FF00,
  59.     INTUIT          => 0x000100,
  60.     MATCH           => 0x000200,
  61.     TRIEE           => 0x000400,
  62.  
  63.     EXTRA           => 0xFF0000,
  64.     TRIEM           => 0x010000,
  65.     OFFSETS         => 0x020000,
  66.     OFFSETSDBG      => 0x040000,
  67.     STATE           => 0x080000,
  68.     OPTIMISEM       => 0x100000,
  69.     STACK           => 0x280000,
  70.     BUFFERS         => 0x400000,
  71. );
  72. $flags{ALL} = -1 & ~($flags{OFFSETS}|$flags{OFFSETSDBG}|$flags{BUFFERS});
  73. $flags{All} = $flags{all} = $flags{DUMP} | $flags{EXECUTE};
  74. $flags{Extra} = $flags{EXECUTE} | $flags{COMPILE};
  75. $flags{More} = $flags{MORE} = $flags{All} | $flags{TRIEC} | $flags{TRIEM} | $flags{STATE};
  76. $flags{State} = $flags{DUMP} | $flags{EXECUTE} | $flags{STATE};
  77. $flags{TRIE} = $flags{DUMP} | $flags{EXECUTE} | $flags{TRIEC};
  78.  
  79. my $installed;
  80. my $installed_error;
  81.  
  82. sub _do_install {
  83.     if ( ! defined($installed) ) {
  84.         require XSLoader;
  85.         $installed = eval { XSLoader::load('re', $VERSION) } || 0;
  86.         $installed_error = $@;
  87.     }
  88. }
  89.  
  90. sub _load_unload {
  91.     my ($on)= @_;
  92.     if ($on) {
  93.         _do_install();        
  94.         if ( ! $installed ) {
  95.             die "'re' not installed!? ($installed_error)";
  96.     } else {
  97.         # We call install() every time, as if we didn't, we wouldn't
  98.         # "see" any changes to the color environment var since
  99.         # the last time it was called.
  100.  
  101.         # install() returns an integer, which if casted properly
  102.         # in C resolves to a structure containing the regex
  103.         # hooks. Setting it to a random integer will guarantee
  104.         # segfaults.
  105.         $^H{regcomp} = install();
  106.         }
  107.     } else {
  108.         delete $^H{regcomp};
  109.     }
  110. }
  111.  
  112. sub bits {
  113.     my $on = shift;
  114.     my $bits = 0;
  115.     unless (@_) {
  116.     require Carp;
  117.     Carp::carp("Useless use of \"re\" pragma"); 
  118.     }
  119.     foreach my $idx (0..$#_){
  120.         my $s=$_[$idx];
  121.         if ($s eq 'Debug' or $s eq 'Debugcolor') {
  122.             setcolor() if $s =~/color/i;
  123.             ${^RE_DEBUG_FLAGS} = 0 unless defined ${^RE_DEBUG_FLAGS};
  124.             for my $idx ($idx+1..$#_) {
  125.                 if ($flags{$_[$idx]}) {
  126.                     if ($on) {
  127.                         ${^RE_DEBUG_FLAGS} |= $flags{$_[$idx]};
  128.                     } else {
  129.                         ${^RE_DEBUG_FLAGS} &= ~ $flags{$_[$idx]};
  130.                     }
  131.                 } else {
  132.                     require Carp;
  133.                     Carp::carp("Unknown \"re\" Debug flag '$_[$idx]', possible flags: ",
  134.                                join(", ",sort keys %flags ) );
  135.                 }
  136.             }
  137.             _load_unload($on ? 1 : ${^RE_DEBUG_FLAGS});
  138.             last;
  139.         } elsif ($s eq 'debug' or $s eq 'debugcolor') {
  140.         setcolor() if $s =~/color/i;
  141.         _load_unload($on);
  142.         last;
  143.         } elsif (exists $bitmask{$s}) {
  144.         $bits |= $bitmask{$s};
  145.     } elsif ($EXPORT_OK{$s}) {
  146.         _do_install();
  147.         require Exporter;
  148.         re->export_to_level(2, 're', $s);
  149.     } else {
  150.         require Carp;
  151.         Carp::carp("Unknown \"re\" subpragma '$s' (known ones are: ",
  152.                        join(', ', map {qq('$_')} 'debug', 'debugcolor', sort keys %bitmask),
  153.                        ")");
  154.     }
  155.     }
  156.     $bits;
  157. }
  158.  
  159. sub import {
  160.     shift;
  161.     $^H |= bits(1, @_);
  162. }
  163.  
  164. sub unimport {
  165.     shift;
  166.     $^H &= ~ bits(0, @_);
  167. }
  168.  
  169. 1;
  170.  
  171. __END__
  172.  
  173.